home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagn_r.zip / PRINTING.SWG / 0033_Printout with error check.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-15  |  4KB  |  177 lines
  1. {$I-}
  2.  
  3. unit Printout;
  4.  
  5. { This unit replaces the Printer unit for output via the write(lst).  Error
  6.   checking is done and a message is printed asking for operator intervention.
  7.   Printing can be terminated by pressing the Escape key.  A flag, Esc_Lst is
  8.   set true if Escape is pressed, and can be used by the program to test for
  9.   that condition.  The program must reset Esc_Lst to false (Esc_Lst := false)
  10.   before trying to print anything else, or the write command will be ignored.
  11.  
  12.   Richard F. Griffin,  Omaha, NE                          14 Jan 1988
  13.   CIS 75206.231
  14.                                                                             }
  15.  
  16. interface
  17.  
  18. uses Crt, Dos;
  19.  
  20. var
  21.   Esc_Lst : boolean;
  22.   Lst: Text;
  23.  
  24. implementation
  25.  
  26. var
  27.    Inch, Fnch : char;
  28.    SecNum : boolean;
  29.    KeyNum : integer;
  30.  
  31. function GetKey : boolean;
  32. begin
  33.    Esc_Lst := false;
  34.    if KeyPressed then begin
  35.       GetKey := true;
  36.       Inch := ReadKey;
  37.       KeyNum := ord(Inch);
  38.       Secnum := KeyNum = 0;
  39.       if Secnum then
  40.       begin
  41.          Fnch := ReadKey;
  42.          Keynum := ord(Fnch);
  43.       end
  44.       else if ord(Inch) <= 27 then Secnum := true else Secnum := false;
  45.    end
  46.    else begin
  47.       Getkey := false;
  48.       secnum := false;
  49.    end;
  50. end;
  51.  
  52. procedure Lst_Err;
  53. var
  54.   AsczStr : string[84];
  55. begin
  56.    gotoxy(2,14);
  57.    AsczStr := concat (#7,'Please Check Printer! ',
  58.                      ' Use [ESC] to Exit, ',
  59.                      'Any Other Key to Continue.');
  60.    write(AsczStr);
  61.    repeat until GetKey;
  62.    if (Secnum) and (Keynum = 27) then Esc_Lst := true;
  63.    gotoxy(2,14);
  64.    write('':length(AsczStr));
  65. end;
  66.  
  67. procedure WriteLst (TheStr : char);
  68. Label Skip;
  69. VAR
  70.   rgstr : Registers;
  71.   goodio : boolean;
  72.   i : integer;
  73. begin
  74.    goodio := false;
  75.    i := 0;
  76.    repeat
  77.       If Esc_Lst then goto Skip;
  78.       with rgstr do
  79.       begin
  80.          dx := $0000;
  81.          ax := $0200;
  82.          intr($17,rgstr);
  83.          while (ax and $8000) = 0 do
  84.          begin
  85.             dx := $0000;
  86.             ax := $0200;
  87.             intr($17,rgstr);
  88.             i := i + 1;
  89.             if i = 20000 then
  90.             begin
  91.                Lst_Err;
  92.                If Esc_Lst then goto Skip;
  93.                i := 0;
  94.             end;
  95.             if GetKey then
  96.                if (Secnum) and (Keynum = 27) then Esc_Lst := true;
  97.             If Esc_Lst then goto Skip;
  98.          end;
  99.          dx := $0000;
  100.          ax := ord(TheStr);
  101.          intr($17,rgstr);
  102.          if (ax and $2900) <> 0 then Lst_Err
  103.              else goodio := true;
  104.          If Esc_Lst then goto Skip;
  105.          if GetKey then
  106.             if (Secnum) and (Keynum = 27) then Esc_Lst := true;
  107.       end;
  108.    until goodio or Esc_Lst;
  109. Skip:
  110. end;
  111.  
  112. {$F+}
  113.  
  114. function LstInOut(var F : TextRec) : integer;
  115. var i : word;
  116. begin
  117.    with F do
  118.    begin
  119.       i := 0;
  120.       while i < BufPos do
  121.       begin
  122.          WriteLst(BufPtr^[i]);
  123.          inc(i);
  124.       end;
  125.       BufPos := 0;
  126.    end;
  127.    LstInOut := 0;
  128. end;
  129.  
  130. function LstClose(var F : TextRec) : integer;
  131. var i : word;
  132. begin
  133.    with F do
  134.    begin
  135.       i := 0;
  136.       while i < BufPos do
  137.       begin
  138.          WriteLst(BufPtr^[i]);
  139.          inc(i);
  140.       end;
  141.       WriteLst(#10);
  142.       WriteLst(#13);
  143.       BufPos := 0;
  144.    end;
  145.    LstClose := 0;
  146. end;
  147.  
  148.  
  149. function LstOpen(var F : TextRec) : integer;
  150. begin
  151.    with F do
  152.    begin
  153.       Mode := fmOutPut;
  154.       InOutFunc := @LstInOut;
  155.       FlushFunc := @LstInOut;
  156.       CloseFunc := @LstClose;
  157.       BufPos := 0;
  158.       LstOpen := 0;
  159.    end;
  160.    Esc_Lst := false;
  161. end;
  162.  
  163. {$F-}
  164.  
  165. begin
  166.    with TextRec(Lst) do
  167.    begin
  168.       Handle := $FFFF;
  169.       Mode := fmClosed;
  170.       BufSize := Sizeof(Buffer);
  171.       BufPtr := @Buffer;
  172.       OpenFunc := @LstOpen;
  173.       Name[0] := #0;
  174.       Rewrite(Lst);
  175.    end;
  176. end.
  177.